PC go! 2008 April/PCgo 2008-04 (DVD).iso/interface/contents/demoversionen_3846/13664/files/Data1.cab/datumtarg.cls

Visual Basic class definition | 2004-03-05 | 19.2 KB | 567 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Target"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

Option Explicit
'/******************************************************************/
'/*                                                                */
'/*                      TurboCAD for Windows                      */
'/*                   Copyright (c) 1993 - 2001                    */
'/*             International Microcomputer Software, Inc.         */
'/*                            (IMSI)                              */
'/*                      All rights reserved.                      */
'/*                                                                */
'/******************************************************************/

'DBAPI constants
Const gkGraphic = 11
Const gkArc = 2
Const gkText = 6
Const gfCosmetic = 128&

'Useful math constants
Const Pi# = 3.14159265

'Real variant types!
Const typeEmpty = 0
Const typeInteger = 2
Const typeLong = 3
Const typeSingle = 4
Const typeDouble = 5
Const typeCurrency = 6
Const typeDate = 7
Const typeString = 8
Const typeObject = 9
Const typeBoolean = 11
Const typeVariant = 12
Const typeIntegerEnum = typeInteger + 100
Const typeLongEnum = typeLong + 100
Const typeStringEnum = typeString + 100

'Stock property pages
Const ppStockPen = 1
Const ppStockBrush = 2
Const ppStockText = 4
Const ppStockInsert = 8
Const ppStockViewport = 16
Const ppStockAuto = 32

'Property Ids
Const idDiam = 1
Const idText1 = 2
Const idText2 = 3
Const idText3 = 4
Const idSymbolSize = 5
Const idFontSize = 6


'Property enums

'Number of properties, pages, wizards
Const NUM_PROPERTIES = 6
Const NUM_PAGES = 1
Const NUM_WIZARDS = 0
Const formCaption = "Datum Target Symbol"
Private Sub Class_Initialize()
    'Initialize class variables
End Sub

'Returns the user-visible description of this RegenMethod
Public Property Get Description() As String
    Description = "SDK_DatumTarget"
End Property

'Returns the persistent class id for this RegenMethod's property section
Public Property Get ClassID() As String
    ClassID = "{FDB6F1CA-9631-11d1-A40A-0000B465872B}"
End Property

'Retrieve types and names
Public Function GetPropertyInfo(Names As Variant, Types As Variant, _
    IDs As Variant, Defaults As Variant) As Long
    ReDim Names(NUM_PROPERTIES), Types(NUM_PROPERTIES), _
        IDs(NUM_PROPERTIES), Defaults(NUM_PROPERTIES)

    Names(0) = "Diam"
    Types(0) = typeInteger
    IDs(0) = idDiam
    Defaults(0) = 1

    Names(1) = "TagAreaSize"
    Types(1) = typeString
    IDs(1) = idText1
    Defaults(1) = "1"

    Names(2) = "DatumLetter"
    Types(2) = typeString
    IDs(2) = idText2
    Defaults(2) = "A"

    Names(3) = "TargetNumber"
    Types(3) = typeString
    IDs(3) = idText3
    Defaults(3) = "1"

    Names(4) = "SymbolSize"
    Types(4) = typeDouble
    IDs(4) = idSymbolSize
    Defaults(4) = 0.5

    Names(5) = "FontSize"
    Types(5) = typeDouble
    IDs(5) = idFontSize
    Defaults(5) = 0.25



'End Scale
    GetPropertyInfo = NUM_PROPERTIES
End Function

'Get the number of property pages supporting this RegenMethod
Public Function GetPageInfo(ByVal AGraphic As Object, StockPages As Long, _
    Names As Variant) As Long
    ReDim Names(NUM_PAGES)

    'Need the form
''    Load frmSample
''    Names(0) = frmSample.Caption
''    Unload frmSample
    Names(0) = formCaption
    StockPages = ppStockBrush + ppStockPen + ppStockAuto
    GetPageInfo = NUM_PAGES
End Function

Public Function GetWizardInfo(Names As Variant) As Long
    ReDim Names(NUM_WIZARDS)
    GetWizardInfo = NUM_WIZARDS
End Function

'Enumerate the names and values of a specified property
Public Function GetEnumNames(ByVal PropID As Long, Names As Variant, Values As Variant) As Long
    GetEnumNames = 0
End Function

Public Function PageControls(ByVal ThisRegenMethod As Object, ByVal Graphic As Object, ByVal PageNumber As Long, ByVal SaveProperties As Boolean) As Boolean
        'Set up error function
        On Error GoTo Failed
Dim Str1$, Str2$, Str3$, SymbolSize#, FontSize#
Dim FontHeight As Double
        If SaveProperties Then
            'OK button on property page was clicked
            'Form is still loaded
            With frmSample
               'Need On Error statement for the case where you have
                'RRect Turbo Shape and ahother "shape" selected
                On Error Resume Next

                Graphic.Properties("Diam") = ImDiam
                Str1 = .Text1.Text
                Graphic.Properties("TagAreaSize") = Str1

                Str2 = .Text2.Text
                Graphic.Properties("DatumLetter") = Str2

                Str3 = .Text3.Text
                Graphic.Properties("TargetNumber") = Str3

                SymbolSize = CDbl(.Text4.Text)
                Graphic.Properties("SymbolSize") = SymbolSize

                FontSize = CDbl(.Text5.Text)
                Graphic.Properties("FontSize") = FontSize


            End With

        Else
            'Property page is about to be opened
            'Make sure the form is loaded
            Load frmSample
            With frmSample
                'If more than one Rough-symbol is selected and they do not
                'have the same properties, don't set up this field
                On Error GoTo NoRType
                ImDiam = Graphic.Properties("Diam")

                Str1 = Graphic.Properties("TagAreaSize")
                .Text1.Text = Str1

                Str2 = Graphic.Properties("DatumLetter")
                .Text2.Text = Str2

                Str3 = Graphic.Properties("TargetNumber")
                .Text3.Text = Str3

                SymbolSize = Graphic.Properties("SymbolSize")
                .Text4.Text = CStr(SymbolSize)

                FontSize = Graphic.Properties("FontSize")
                .Text5.Text = CStr(FontSize)
NoRType:
            End With

        End If

        PageControls = True
        Exit Function

Failed:
        'For debugging purposes, report that an error occurred
        If Err.Number <> 0 Then
            MsgBox "Error in PageControls: " & Err.Description
        End If

        'Return false if an error occurred
        PageControls = False
End Function

Public Function PageDone(ByVal ThisRegenMethod As Object, Optional PageNumber As Variant)
        'Done with form
        Unload frmSample
End Function

Public Function PropertyPages(ByVal ThisRegenMethod As Object, Optional PageNumber As Variant) As Boolean
    With frmSample
        .Show vbModal
        PropertyPages = Not .DialogCanceled
    End With
End Function

Public Function Wizard(ByVal ThisRegenMethod As Object, Optional WizardNumber As Variant) As Boolean
    Wizard = False
End Function

'Called when vertex has been moved, or other geometry change
Public Function OnGeometryChanged(ByVal Graphic As Object, ByVal GeomID As Long, paramOld As Variant, paramNew As Variant)
    'Do nothing
    'Regen Graphic
End Function

'Called when vertex is moved, or other geometry change
Public Function OnGeometryChanging(ByVal Graphic As Object, ByVal GeomID As Long, paramOld As Variant, paramNew As Variant) As Boolean
    'OK to continue with change
    OnGeometryChanging = True
End Function

Public Function OnNewGraphic(ByVal grfThis As Object, ByVal boolCopy As Boolean) As Boolean
    If boolCopy Then
        'Vertices are already added for us...
        OnNewGraphic = True
        Exit Function
    End If
    On Error GoTo Failed
    ImDiam = 1
    'New Graphic being created
    'X, Y, Z, PenDown, Selectable, Snappable, Editable, Linkable
    'First Vertex is "Center" vertex
    grfThis.Vertices.Add 0#, 0#, 0#, False, True, True, False, True
    'Second Vertex is additional
    grfThis.Vertices.Add 1, 0#, 0#, False, True, True, False, True
    'Third Vertex is additional
    grfThis.Vertices.Add 0, 0, 0#, False, True, True, True, True
    'Forth Vertex is additional
    grfThis.Vertices.Add 0, 0, 0#, False, True, True, True, True


    grfThis.Properties("LimitVertices") = 4
    OnNewGraphic = True
    Exit Function

Failed:
    'Return false on failure
    OnNewGraphic = False
End Function

'Function called whenever a copy of a graphic is being made
Public Function OnCopyGraphic(ByVal grfCopy As Object, ByVal grfSource As Object) As Boolean
    'Return false on failure
    OnCopyGraphic = True
End Function

'Notification function called after graphic property is saved
Public Function OnPropertyChanged(ByVal Graphic As Object, ByVal PropID As Long, _
        ValueOld As Variant, ValueNew As Variant)
    'Do nothing
End Function

'Notification function called when graphic property is saved
Public Function OnPropertyChanging(ByVal Graphic As Object, ByVal PropID As Long, _
        ValueOld As Variant, ValueNew As Variant) As Boolean
    'OK to proceed
    OnPropertyChanging = True
End Function

'Notification function called when graphic property is retrieved
Public Function OnPropertyGet(ByVal Graphic As Object, ByVal PropID As Long)
    'Do nothing
End Function

'Called when we need to update our object
Public Function Regen(ByVal grfThis1 As Object)
        'Setup error handler
        On Error GoTo Failed
Dim grfThis As Graphic
        Set grfThis = grfThis1
        grfThis.Properties("PenStyle") = "CONTINUOUS"
        'Set up lock (prevent recursion)
        Dim LockCount&
        LockCount& = grfThis.RegenLock

        'Setup error handler (make sure lock is removed)
        On Error GoTo FailedLock
        If LockCount& = 0 Then
            'Delete any previous cosmetic children
            grfThis.Graphics.Clear gfCosmetic



Dim Diam%, Str1$, Str2$, Str3$, d#, FontSize#
Dim Gr As Graphic

            Diam = grfThis.Properties("Diam")
            Str1 = grfThis.Properties("TagAreaSize")
            Str2 = grfThis.Properties("DatumLetter")
            Str3 = grfThis.Properties("TargetNumber")
            d = grfThis.Properties("SymbolSize")
            FontSize = grfThis.Properties("FontSize")

            'Add child Graphics
Dim Salp#, Calp#, L#
Dim X0#, Y0#, X1#, Y1#
            With grfThis.Vertices
                X0 = .Item(0).X
                Y0 = .Item(0).Y
                X1 = .Item(1).X
                Y1 = .Item(1).Y
                L = Sqr((X1 - X0) * (X1 - X0) + (Y1 - Y0) * (Y1 - Y0))
                Salp = (Y1 - Y0) / L
                Calp = (X1 - X0) / L
            End With
Dim alp#
            If Calp = 0# Then
               If Salp > 0 Then
                   alp = Pi / 2#
                   GoTo LL
               End If
               If Salp < 0 Then
                   alp = 3# * Pi / 2#
                   GoTo LL
               End If
            End If

            If Salp >= 0# And Calp > 0# Then
               alp = Atn(Abs(Salp / Calp))
            End If
            If Salp >= 0# And Calp < 0# Then
               alp = Pi - Atn(Abs(Salp / Calp))
            End If
            If Salp <= 0# And Calp < 0# Then
               alp = Pi + Atn(Abs(Salp / Calp))
            End If
            If Salp <= 0# And Calp > 0# Then
               alp = 2# * Pi - Atn(Abs(Salp / Calp))
            End If
LL:
            If alp > 6.28 Then alp = 0#
            If alp < 0.01 Then alp = 0#

            Salp = Sin(alp)
            Calp = Cos(alp)
            X1 = X0 + d / 2 * Cos(alp)
            Y1 = Y0 + d / 2 * Sin(alp)
            grfThis.Vertices(1).X = X1
            grfThis.Vertices(1).Y = Y1

     ' Add Cosmetic
        Set Gr = grfThis.Graphics.AddCircleCenterAndPoint(0, 0, 0, 0 + d / 2, 0, 0)
            Gr.Cosmetic = True
            Gr.RotateAxis alp, 0, 0, 1, 0, 0, 0
            Gr.MoveRelative X0, Y0, 0
        Set Gr = grfThis.Graphics.AddLineSingle(-d / 2, 0, 0, 0 + d / 2, 0, 0)
            Gr.Cosmetic = True
            Gr.RotateAxis alp, 0, 0, 1, 0, 0, 0
            Gr.MoveRelative X0, Y0, 0
Dim GrGroup As Graphic
Dim Gr1 As Graphic, Gr2 As Graphic
Dim BBox As BoundingBox
Dim xmax1#, ymax1#, xmin1#, ymin1#
Dim xmax2#, ymax2#, xmin2#, ymin2#
Dim xc#, yc#
Dim x2#, y2#, x3#, y3#
Dim xx0#, yy0#, xx1#, yy1#, xx2#, yy2#
        With grfThis.Vertices
            x2 = .Item(2).X
            y2 = .Item(2).Y
            x3 = .Item(3).X
            y3 = .Item(3).Y
        End With
        'Diameter an top


Dim hSym#
        hSym = FontSize

        If Diam > 0 Or Str1 <> "" Then
            Set GrGroup = grfThis.Graphics.Add(11)
            GrGroup.Cosmetic = True
            xmax1 = 0
            If Diam > 0 Then
                Set Gr1 = GrGroup.Graphics.AddText(Chr(110), 0, 0.7 * hSym, 0, 0.7 * hSym)
                    Gr1.Cosmetic = True
                Gr1.Properties("TextFont") = "gdt.shx"
                Gr1.Properties("TextStyle") = 0

                xmax1 = Gr1.CalcBoundingBox.Max.X
                xmin1 = Gr1.CalcBoundingBox.Min.X
            End If
            xmax2 = xmax1
            If Str1 <> "" Then
                Set Gr2 = GrGroup.Graphics.AddText(Str1, xmax1, hSym, 0, hSym)
                    Gr2.Cosmetic = True
                xmax2 = Gr2.CalcBoundingBox.Max.X
                xmin2 = Gr2.CalcBoundingBox.Min.X
            End If
            If Sqr((x2 - X0) * (x2 - X0) + (y2 - Y0) * (y2 - Y0)) < 0.6 * d Then
                GrGroup.MoveRelative -(xmax2 - xmin1) / 2, 0, 0
                GrGroup.RotateAxis alp, 0, 0, 1, 0, 0, 0
                GrGroup.MoveRelative X0, Y0, 0
                grfThis.Vertices(2).X = X0 + d / 4 * Cos(alp + Pi / 2)
                grfThis.Vertices(2).Y = Y0 + d / 4 * Sin(alp + Pi / 2)
            Else
                xmax1 = GrGroup.CalcBoundingBox.Max.X
                ymax1 = GrGroup.CalcBoundingBox.Max.Y
                xmin1 = GrGroup.CalcBoundingBox.Min.X
                ymin1 = GrGroup.CalcBoundingBox.Min.Y
                xc = (xmax1 + xmin1) / 2
                yc = (ymax1 + ymin1) / 2
                GrGroup.MoveRelative x2 - xc, y2 - yc, 0
                Set Gr = grfThis.Graphics.Add(11)
                    Gr.Cosmetic = True
                If x2 > X0 Then
                    xx0 = X0 + d / 4 * Cos(alp + Pi / 2)
                    yy0 = Y0 + d / 4 * Sin(alp + Pi / 2)
                    xx1 = x2 - 1.6 * (xmax1 - xmin1) / 2
                    yy1 = y2
                    xx2 = x2 - (xmax1 - xmin1) / 2
                    yy2 = y2
                Else
                    xx0 = X0 + d / 4 * Cos(alp + Pi / 2)
                    yy0 = Y0 + d / 4 * Sin(alp + Pi / 2)
                    xx1 = x2 + 1.6 * (xmax1 - xmin1) / 2
                    yy1 = y2
                    xx2 = x2 + (xmax1 - xmin1) / 2
                    yy2 = y2
                End If
                With Gr.Vertices
                    .Add xx0, yy0, 0
                    .Add xx1, yy1, 0
                    .Add xx2, yy2, 0
                End With

                Set Gr = grfThis.Graphics.AddCircleCenterAndPoint(xx0, yy0, 0, xx0 + d / 20, yy0, 0)
                    Gr.Cosmetic = True
                    Gr.Properties("BrushStyle") = "Solid"
            End If
        End If

    'Bottom
Dim Gr3 As Graphic, Gr4 As Graphic
        If Str2 <> "" Or Str3 <> "" Then
            Set GrGroup = grfThis.Graphics.Add(11)
            GrGroup.Cosmetic = True
            xmax1 = 0
            If Str2 <> "" Then
                Set Gr3 = GrGroup.Graphics.AddText(Str2, 0, 0.15 * hSym, 0, hSym)
                    Gr3.Cosmetic = True
                xmax1 = Gr3.CalcBoundingBox.Max.X
                ymax1 = Gr3.CalcBoundingBox.Max.Y
                xmin1 = Gr3.CalcBoundingBox.Min.X
                ymin1 = Gr3.CalcBoundingBox.Min.Y
            End If
            xmax2 = xmax1
            If Str3 <> "" Then
                Set Gr4 = GrGroup.Graphics.AddText(Str3, xmax1, 0.15 * hSym, 0, hSym)
                    Gr4.Cosmetic = True
                xmax2 = Gr4.CalcBoundingBox.Max.X
                ymax2 = Gr4.CalcBoundingBox.Max.Y
                xmin2 = Gr4.CalcBoundingBox.Min.X
                ymin2 = Gr4.CalcBoundingBox.Min.Y
            End If
            If Sqr((x3 - X0) * (x3 - X0) + (y3 - Y0) * (y3 - Y0)) < 0.6 * d Then
                GrGroup.MoveRelative -(xmax2 - xmin1) / 2, 0, 0
                GrGroup.RotateAxis alp, 0, 0, 1, 0, 0, 0
                GrGroup.MoveRelative X0, Y0, 0
                grfThis.Vertices(3).X = X0 + d / 4 * Cos(alp + 3 * Pi / 2)
                grfThis.Vertices(3).Y = Y0 + d / 4 * Sin(alp + 3 * Pi / 2)
            Else
                xmax1 = GrGroup.CalcBoundingBox.Max.X
                ymax1 = GrGroup.CalcBoundingBox.Max.Y
                xmin1 = GrGroup.CalcBoundingBox.Min.X
                ymin1 = GrGroup.CalcBoundingBox.Min.Y
                xc = (xmax1 + xmin1) / 2
                yc = (ymax1 + ymin1) / 2
                GrGroup.MoveRelative x3 - xc, y3 - yc, 0
                Set Gr = grfThis.Graphics.Add(11)
                    Gr.Cosmetic = True
                If x3 > X0 Then
                    xx0 = X0 + d / 4 * Cos(alp + 3 * Pi / 2)
                    yy0 = Y0 + d / 4 * Sin(alp + 3 * Pi / 2)
                    xx1 = x3 - 1.6 * (xmax1 - xmin1) / 2
                    yy1 = y3
                    xx2 = x3 - (xmax1 - xmin1) / 2
                    yy2 = y3
                Else
                    xx0 = X0 + d / 4 * Cos(alp + 3 * Pi / 2)
                    yy0 = Y0 + d / 4 * Sin(alp + 3 * Pi / 2)
                    xx1 = x3 + 1.6 * (xmax1 - xmin1) / 2
                    yy1 = y3
                    xx2 = x3 + (xmax1 - xmin1) / 2
                    yy2 = y3
                End If
                With Gr.Vertices
                    .Add xx0, yy0, 0
                    .Add xx1, yy1, 0
                    .Add xx2, yy2, 0
                End With

                Set Gr = grfThis.Graphics.AddCircleCenterAndPoint(xx0, yy0, 0, xx0 + d / 20, yy0, 0)
                    Gr.Cosmetic = True
                    Gr.Properties("BrushStyle") = "Solid"
            End If

        End If

    End If

    grfThis.RegenUnlock

    Exit Function

FailedLock:
        'Remove lock
        grfThis.RegenUnlock
Failed:
        If Err.Number <> 0 Then
            MsgBox "Regen error: " & Err.Description
        End If
End Function

Public Function Draw(ByVal grfThis As Object, ByVal view As Object, Optional mat As Variant) As Boolean
    'Return True if we did the redraw (no further processing necessary, no children will be drawn).
    'Since this is just a test, we return False to let TurboCAD do the drawing operation.
    Draw = False
End Function